home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / glass / glass.lha / GLASS / tmpas / paslib.pt < prev    next >
Text File  |  1990-10-02  |  14KB  |  618 lines

  1. .. file: paslib.pt
  2. ..
  3. .. Library of utility functions for the tm pascal code.
  4.  
  5. { ---- start of ${tplfilename} ---- }
  6.  
  7. .if ${index tmgetc $(need_misc)}
  8. { Read a character from file 'f' in the global variable 'tmcurchar'.
  9.   The eoln condition is automagically converted to a special
  10.   'tmeolnchar' character.  During eof 'tmeofchar' is put
  11.   into 'tmcurchar'.
  12. }
  13. procedure tmgetc( var f: text );
  14. begin
  15.     if eof( f ) then
  16.     tmcurchar := tmeofchar
  17.     else if eoln( f ) then begin
  18.     readln( f );
  19.     tmcurchar := tmeolnchar
  20.     end
  21.     else
  22.     read( f, tmcurchar );
  23. end; { tmgetc }
  24.  
  25. .endif
  26. .if ${index tmreadc $(need_misc)}
  27. { Read a character from file 'f' without skipping
  28.   preceding spaces. Handle octal and character backslash escapes.
  29. }
  30. procedure tmreadc( var f: text; var c: char );
  31. var
  32.     val: integer;
  33.     digits : set of char;
  34.  
  35. begin
  36.     digits := ['0'..'7'];
  37.     if tmcurchar = '\' then begin
  38.     tmgetc( f );
  39.     if tmcurchar in ['b','f','n','r','t','v'] then begin
  40.         case tmcurchar of
  41.         'b': c := chr( 8 );
  42.         'f': c := chr( 12 );
  43.         'n': c := chr( 10 );
  44.         'r': c := chr( 13 );
  45.         't': c := chr( 9 );
  46.         'v': c := chr( 11 );
  47.         end;
  48.         tmgetc( f )
  49.     end
  50.     else begin
  51.         if tmcurchar in digits then begin
  52.         val := ord( tmcurchar ) - ord( '0' );
  53.         tmgetc( f );
  54.         if tmcurchar in digits then begin
  55.             val := val*8 + ord( tmcurchar ) - ord( '0' );
  56.             tmgetc( f );
  57.             if tmcurchar in digits then begin
  58.             val := val*8 + ord( tmcurchar ) - ord( '0' );
  59.             tmgetc( f );
  60.             end
  61.         end;
  62.         c := chr( val );
  63.         end
  64.         else begin
  65.         c := tmcurchar;
  66.         tmgetc( f );
  67.         end;
  68.     end;
  69.     end
  70.     else begin
  71.     c := tmcurchar;
  72.     tmgetc( f );
  73.     end;
  74. end; { tmreadc }
  75.  
  76. .endif
  77. .if ${index tmreadspc $(need_misc)}
  78. { Skip all space characters and Miranda style comment.
  79.   For implementation reasons it is assumed that a single
  80.   '|' starts comment instead of '||'.
  81.   After the call 'tmcurchar' contains the next character.
  82. }
  83. procedure tmreadspc( var f: text );
  84. var
  85.     busy: boolean;
  86.     spaceset: set of char;
  87.  
  88. begin
  89.     spaceset := [' ', chr(9), chr(10), tmeolnchar, chr(11), chr(13)];
  90.     busy := true;
  91.     while busy do begin
  92.     busy := false;
  93.     if (tmcurchar in spaceset) then begin
  94.         tmgetc( f );
  95.         busy := true
  96.     end;
  97.     if (tmcurchar = '|') then begin
  98.         repeat
  99.         tmgetc( f );
  100.         until tmcurchar in [tmeolnchar,tmeofchar];
  101.         busy := true
  102.     end;
  103.     end;
  104. end; { tmreadspc }
  105.  
  106. .endif
  107. .if ${index tmneedc $(need_misc)}
  108. { Do 'tmreadspc' and try to character 'needc'. Write an
  109.   error message and return true if this is not possible, else
  110.   return false.
  111. }
  112. function tmneedc( var f, rf: text; needc: char ): boolean;
  113. var
  114.     err: boolean;
  115.  
  116. begin
  117.     err := false;
  118.     tmreadspc( f );
  119.     if tmcurchar = tmeofchar then begin
  120.     writeln( rf, 'Expected "', needc, '" but got EOF' );
  121.     err := true
  122.     end
  123.     else if tmcurchar <> needc then begin
  124.     writeln( rf, 'Expected "', needc, '" but got "', tmcurchar, '"' );
  125.     err := true
  126.     end
  127.     else
  128.     tmgetc( f );
  129.     tmneedc := err
  130. end; { tmneedc }
  131.  
  132. .endif
  133. .if ${index tmreadobrac $(need_misc)}
  134. { Skip all space characters, and count the open brackets (`(')
  135.   that you encounter up to the first other character. Set 'n'
  136.   to the number of open brackets found.
  137. }
  138. procedure tmreadobrac( var f: text; var n: integer );
  139. var
  140.     done: boolean;
  141.  
  142. begin
  143.     n := 0;
  144.     done := false;
  145.     repeat
  146.     tmreadspc( f );
  147.     if tmcurchar = '(' then begin
  148.         tmgetc( f );
  149.         n := n+1;
  150.     end
  151.     else
  152.         done := true
  153.     until done;
  154. end; { tmreadobrac }
  155.  
  156. .endif
  157. .if ${index tmreadcbrac $(need_misc)}
  158. { Skip all space characters, and try to read `n' close
  159.   brackets. Give an error if this is not possible.
  160. }
  161. function tmreadcbrac( var f, rf:text; n: integer ): boolean;
  162. var
  163.     err: boolean;
  164.  
  165. begin
  166.     err := false;
  167.     while (n>0) and (not err) do begin
  168.         err := tmneedc( f, rf, ')' );
  169.     n := n-1
  170.     end;
  171.     tmreadcbrac := err
  172. end;
  173.  
  174. .endif
  175. .if ${index tmwritec $(need_misc)}
  176. { Write a character to file 'f'. Use an escape sequence if
  177.   necessary }
  178. procedure tmwritec( var f: text; c: char );
  179. var
  180.     ccode: integer;
  181.  
  182.     { Write the digits of an octal number 'n' to file 'f' }
  183.     procedure writeoct( var f: text; n: integer );
  184.     begin
  185.     if( n<8 ) then begin
  186.         write( f, chr( ord('0')+n ) );
  187.     end
  188.     else begin
  189.         writeoct( f, n div 8 );
  190.         write( f, chr( ord('0')+(n mod 8) ) );
  191.     end;
  192.     end; { writeoct }
  193.  
  194. begin
  195.     ccode := ord( c );
  196.     if ccode in [8, 12, 10, 13, 9, 11] then begin
  197.     case ccode of
  198.         8 : write( f, '\b' );
  199.         12: write( f, '\f' );
  200.         10: write( f, '\n' );
  201.         13: write( f, '\r' );
  202.         9 : write( f, '\t' );
  203.         11: write( f, '\v' );
  204.     end;
  205.     end
  206.     else if c in ['''', '"', '\'] then begin
  207.     write( f, '\', c );
  208.     end
  209.     else if (ccode>=ord(' ')) and (ccode<=ord('~')) then begin
  210.     write( f, c );
  211.     end
  212.     else begin
  213.     write( f, '\' );
  214.     writeoct( f, ccode );
  215.     end;
  216. end; { tmwritec }
  217.  
  218. .endif
  219. .if ${index Readinteger $(need_misc)}
  220. { Read<type> function for Pascal type `integer' }
  221. function Readinteger( var f, rf: text; var n: integer ): boolean;
  222. var
  223.     braccnt: integer;
  224.     done: boolean;
  225.     err: boolean;
  226.     gotadig: boolean;
  227.     neg: boolean;
  228.  
  229. begin
  230.     n := 0;
  231.     neg := false;
  232.     err := false;
  233.     tmreadobrac( f, braccnt );
  234.     tmreadspc( f );
  235.     if (tmcurchar in ['-','+']) then begin
  236.     neg := (tmcurchar = '-');
  237.     tmgetc( f )
  238.     end;
  239.     gotadig := false;
  240.     repeat
  241.     done := true;
  242.     if (tmcurchar in ['0'..'9']) then begin
  243.         n:=n*10 + (ord(tmcurchar)-ord('0'));
  244.         tmgetc( f );
  245.         done := false;
  246.         gotadig := true
  247.     end;
  248.     until done;
  249.     if not gotadig then begin
  250.     write( rf, 'expected integer but got ' );
  251.     if tmcurchar = tmeofchar then
  252.         writeln( rf, 'EOF' )
  253.     else
  254.         writeln( rf, 'char with code ', ord( tmcurchar ):3 );
  255.     err := true 
  256.     end;
  257.     if neg then
  258.     n := -n;
  259.     if not err then err := tmreadcbrac( f, rf, braccnt );
  260.     Readinteger := err;
  261. end; { Readinteger }
  262.  
  263. .endif
  264. .if ${index Writeinteger $(need_misc)}
  265. { Write an integer to file 'f'. Negative numbers are surrounded
  266.   by () or else the Miranda parser will get angry. }
  267. procedure Writeinteger( var f: text; n: integer );
  268. begin
  269.     if n>=0 then
  270.     writeln( f, n:1 )
  271.     else
  272.     writeln( f, '(', n:1, ')' )
  273. end; { Writeinteger }
  274.  
  275. .endif
  276. .if ${index Cmpinteger $(need_misc)}
  277. { Compare two integers }
  278. function Cmpinteger( a, b: integer ): integer;
  279. begin
  280.     Cmpinteger := a-b
  281. end; { Cmpinteger }
  282.  
  283. .endif
  284. .if ${index Rfreinteger $(need_misc)}
  285. procedure Rfreinteger( var i: integer );
  286. begin
  287.     i := 0;
  288. end;
  289.  
  290. .endif
  291. .if ${index Copyinteger $(need_misc)}
  292. function Copyinteger( i: integer ): integer;
  293. begin
  294.     Copyinteger := i;
  295. end; { Copyinteger }
  296.  
  297. .endif
  298. .if ${index Readreal $(need_misc)}
  299. { read<type> function for Pascal type `real' }
  300. { I STRONGLY disapprove of this method of converting a
  301.   string of chars to a real number, because precision will be lost,
  302.   but for the moment this is the best I can do in Pascal (CvR).
  303. }
  304. function Readreal( var f, rf: text; var r: real ): boolean;
  305. var
  306.     busy: boolean;
  307.     done: boolean;
  308.     gotadig: boolean;
  309.     braccnt: integer;    { number of open brackets }
  310.     err: boolean;
  311.     stopit : boolean;    { true if number must have been completed }
  312.     neg: boolean;    { mantissa sign }
  313.     xneg: boolean;    { exponent sign }
  314.     mantissa: real;    { mantissa }
  315.     fracdiv: real;    { divisor for construction of fraction part }
  316.     xp: integer;    { exponent }
  317.  
  318.     { calculate 10^n recursively. Assumes n>=0 }
  319.     function pow10( n: integer ): real;
  320.     var
  321.     i: real;
  322.  
  323.     begin
  324.     if n<1 then
  325.         pow10 := 1
  326.     else begin
  327.         i := pow10( n div 2 );
  328.         if odd( n ) then
  329.         pow10 := 10 * i * i
  330.         else
  331.         pow10 := i * i
  332.     end;
  333.     end; { pow10 }
  334.  
  335. begin 
  336.     stopit := false;
  337.     mantissa := 0;
  338.     err := false;
  339.     tmreadobrac( f, braccnt );
  340.     tmreadspc( f );
  341.     if tmcurchar = tmeofchar then begin
  342.     writeln( rf, 'Expected integer but got EOF' );
  343.     err := true;
  344.     end;
  345.     neg := false;
  346.     if (not err) and (tmcurchar in ['-','+']) then begin
  347.     neg := (tmcurchar = '-');
  348.     tmgetc( f )
  349.     end;
  350.     if not err then begin
  351.     busy := true;
  352.     gotadig := false;
  353.     while busy do begin
  354.         busy := false;
  355.         if (tmcurchar in ['0'..'9']) then begin
  356.         mantissa:=mantissa*10 + (ord(tmcurchar)-ord('0'));
  357.         tmgetc( f );
  358.         busy := true;
  359.         gotadig := true
  360.         end;
  361.     end;
  362.     if not gotadig then begin
  363.         write( rf, 'expected digits but got ' );
  364.         if tmcurchar = tmeofchar then
  365.         writeln( rf, 'EOF' )
  366.         else
  367.         writeln( rf, 'char with code ', ord( tmcurchar ):3 );
  368.         err := true 
  369.     end;
  370.     end;
  371.     fracdiv := 0.1;
  372.     if (not err) and (tmcurchar = '.') then begin
  373.     tmgetc( f );
  374.     done := false;
  375.     repeat
  376.         if tmcurchar in ['0'..'9'] then begin
  377.         mantissa := mantissa + (ord(tmcurchar)-ord('0'))*fracdiv;
  378.         tmgetc( f );
  379.         fracdiv := fracdiv/10;
  380.         end
  381.         else
  382.         done := true;
  383.     until done;
  384.     end;
  385.     xp := 0;
  386.     xneg := false;
  387.     if (not err) and (tmcurchar in ['e', 'E']) then begin
  388.     tmgetc( f );
  389.     if (tmcurchar in ['-','+']) then begin
  390.         xneg := (tmcurchar = '-');
  391.         tmgetc( f )
  392.     end;
  393.     gotadig := false;
  394.     repeat
  395.         done := true;
  396.         if (tmcurchar in ['0'..'9']) then begin
  397.         xp:=xp*10 + (ord(tmcurchar)-ord('0'));
  398.         tmgetc( f );
  399.         done := false;
  400.         gotadig := true
  401.         end;
  402.     until done;
  403.     if not gotadig then begin
  404.         write( rf, 'expected exponent but got ' );
  405.         if tmcurchar = tmeofchar then
  406.         writeln( rf, 'EOF' )
  407.         else
  408.         writeln( rf, 'char with code ', ord( tmcurchar ):3 );
  409.         err := true 
  410.     end;
  411.     end;
  412.     if xneg then
  413.     r := mantissa/pow10( xp )
  414.     else
  415.     r := mantissa * pow10( xp );
  416.     if neg then
  417.     r := -r;
  418.     if not err then err := tmreadcbrac( f, rf, braccnt );
  419.     Readreal := err
  420. end; { Readreal }
  421.  
  422. .endif
  423. .if ${index Writereal $(need_misc)}
  424. { Write a real to file 'f'. Negative numbers are surrounded
  425.   by () or else the Miranda parser will get angry. }
  426. procedure Writereal( var f: text; r: real );
  427. begin
  428.     if r>=0 then
  429.     writeln( f, r )
  430.     else
  431.     writeln( f, '(', r, ')' )
  432. end; { Writereal }
  433.  
  434. .endif
  435. .if ${index Cmpreal $(need_misc)}
  436. { Compare two reals }
  437. function Cmpreal( a, b: real ): integer;
  438. begin
  439.     if( a>b ) then
  440.     Cmpreal := 1
  441.     else if ( a<b ) then
  442.     Cmpreal := -1
  443.     else
  444.     Cmpreal := 0;
  445. end; { Cmpreal }
  446.  
  447. .endif
  448. .if ${index Rfrereal $(need_misc)}
  449. procedure Rfrereal( var i: real );
  450. begin
  451.     i := 0.0;
  452. end;
  453.  
  454. .endif
  455. .if ${index Copyreal $(need_misc)}
  456. function Copyreal( i: real ): real;
  457. begin
  458.     Copyreal := i;
  459. end; { Copyreal }
  460.  
  461. .endif
  462. .if ${index Readboolean $(need_misc)}
  463. { Read a boolean from file 'f' into boolean 'b'.
  464.   A boolean in represented by the constructors 'True' or
  465.   'False' with the obvious interpretation.
  466. }
  467. function Readboolean( var f, rf: text; var b: boolean ): boolean;
  468. const
  469.     maxlen = 5;
  470.  
  471. type
  472.     consnm = packed array [1..maxlen] of char;
  473.  
  474. var
  475.     braccnt: integer;
  476.     word: consnm;
  477.     err: boolean;
  478.     ix: integer;
  479.     busy: boolean;
  480.     alnumset: set of char;
  481.  
  482. begin
  483.     b := false;
  484.     alnumset := ['F', 'T', 'a', 'e', 'l', 'r', 's', 'u'];
  485.     word := '     ';
  486.     ix := 1;
  487.     err := false;
  488.     tmreadobrac( f, braccnt );
  489.     tmreadspc( f );
  490.     if not (tmcurchar in alnumset) then begin
  491.     write( rf, 'expected boolean but got ' );
  492.     if tmcurchar = tmeofchar then
  493.         writeln( rf, 'EOF' )
  494.     else
  495.         writeln( rf, 'char with code ', ord( tmcurchar ):3 );
  496.     err := true
  497.     end;
  498.     busy := true;
  499.     while (not err) and busy and (tmcurchar in alnumset) do begin
  500.     if ix>maxlen then begin
  501.         writeln( rf, 'name too long for boolean: "', word, tmcurchar,'"' );
  502.         err := true
  503.     end
  504.     else begin
  505.         word[ix] := tmcurchar;
  506.         tmgetc( f );
  507.         ix := ix+1
  508.     end;
  509.     if not (tmcurchar in alnumset) then
  510.         busy := false;
  511.     end;
  512.     if not err then begin
  513.         if word = 'True ' then begin
  514.                 b := true
  515.         end
  516.         else if word = 'False' then begin
  517.                 b := false
  518.         end
  519.         else begin
  520.             writeln( rf, 'bad constructor for boolean: "', word, '"' );
  521.             err:=true
  522.         end;
  523.     end;
  524.     if not err then err := tmreadcbrac( f, rf, braccnt );
  525.     Readboolean := err;
  526. end; { Readboolean }
  527.  
  528. .endif
  529. .if ${index Writeboolean $(need_misc)}
  530. { Write a boolean to file 'f'. A boolean in represented by the
  531.   constructors 'True' or 'False' with the obvious interpretation.
  532. }
  533. procedure Writeboolean( var f: text; b: boolean );
  534. begin
  535.     if b then
  536.     write( f, 'True' )
  537.     else
  538.     write( f, 'False' );
  539. end; { Writeboolean }
  540.  
  541. .endif
  542. .if ${index Cmpboolean $(need_misc)}
  543. { Compare two booleans }
  544. function Cmpboolean( a, b: boolean ): integer;
  545. begin
  546.     Cmpboolean := ord( a ) - ord( b )
  547. end; { Cmpboolean }
  548.  
  549. .endif
  550. .if ${index Rfreboolean $(need_misc)}
  551. procedure Rfreboolean( var i: boolean );
  552. begin
  553.     i := false;
  554. end;
  555.  
  556. .endif
  557. .if ${index Copyboolean $(need_misc)}
  558. function Copyboolean( i: boolean ): boolean;
  559. begin
  560.     Copyboolean := i;
  561. end; { Copyboolean }
  562.  
  563. .endif
  564. .if ${index Readchar $(need_misc)}
  565. { Read a char from file 'f' into char 'c'. }
  566. function Readchar( var f, rf: text; var c: char ): boolean;
  567. var
  568.     braccnt: integer;
  569.     err: boolean;
  570.  
  571. begin
  572.     tmreadobrac( f, braccnt );
  573.     err := tmneedc( f, rf, '''' );
  574.     if not err then begin
  575.     tmreadc( f, c );
  576.     err := tmneedc( f, rf, '''' );
  577.     end;
  578.     if not err then err := tmreadcbrac( f, rf, braccnt );
  579.     Readchar := err;
  580. end; { Readchar }
  581.  
  582. .endif
  583. .if ${index Writechar $(need_misc)}
  584. { Write a char to file 'f'. A char in represented by the
  585.   constructors 'True' or 'False' with the obvious interpretation.
  586. }
  587. procedure Writechar( var f: text; c: char );
  588. begin
  589.     write( f, '''' );
  590.     tmwritec( f, c );
  591.     writeln( f, '''' );
  592. end; { Writechar }
  593.  
  594. .endif
  595. .if ${index Cmpchar $(need_misc)}
  596. { Compare two chars }
  597. function Cmpchar( a, b: char ): integer;
  598. begin
  599.     Cmpchar := ord( a ) - ord( b )
  600. end; { Cmpchar }
  601.  
  602. .endif
  603. .if ${index Rfrechar $(need_misc)}
  604. procedure Rfrechar( var i: char );
  605. begin
  606.     i := tmeofchar;
  607. end;
  608.  
  609. .endif
  610. .if ${index Copychar $(need_misc)}
  611. function Copychar( i: char ): char;
  612. begin
  613.     Copychar := i;
  614. end; { Copychar }
  615.  
  616. .endif
  617. { ---- end of ${tplfilename} ---- }
  618.